home *** CD-ROM | disk | FTP | other *** search
/ Tech Arsenal 1 / Tech Arsenal (Arsenal Computer).ISO / tek-02 / storage.zip / STORAGE.PAS < prev    next >
Pascal/Delphi Source File  |  1991-02-09  |  18KB  |  615 lines
  1. Unit Storage;
  2.  
  3. {  STORAGE.PAS - 13 Jan 91
  4.  
  5.    This unit was created to replace the original system storage that was
  6.    created for the DMG.  It is designed to be object oriented and will
  7.    also alow for external compression routines to be designed into the
  8.    system with a registration code for each.
  9.  
  10.    The system will take a buffer pointer and run it through the compressor
  11.    until it reaches "BufBytes" number of characters in the buffer.  Once the
  12.    compressor is finished, the resulting bitstream is then written to the
  13.    disk.  An index number is returned for where this was written.
  14.  
  15.    The system that reads the messages only needs an index and filename.
  16.    It will create a buffer for the message up to the memory restraints.
  17.  
  18.    You MUST do a .done when you are through with the buffer or the space
  19.    will not be released to the heap.
  20.  
  21.    __________________________________________________________________________
  22.  
  23.    MODIFICATIONS:
  24.  
  25.    09 Feb 91 - Removed the original compression routines (The old code is
  26.                still at the end of the listing it anyone cares) and replaced
  27.                them with a technique based on the SPLAY tree algorithms.  The
  28.    original code for this came from the file SPLAY2.ZIP written by Kim
  29.    Kokkonen from TurboPower Software.  Documentation on this compression
  30.    routine can be found from an article by Douglas W. Jones, "Application
  31.    of Splay Trees to Data Compression", in Communications of the ACM,
  32.    August 1988, page 996.
  33.  
  34.    Other changes include creating a message header for each compressed
  35.    message with an overhead of (currently) nine bytes.  Note that I am
  36.    reserving compression types 0..10 for myself and anyone can use the
  37.    others to their hears desires.
  38.  
  39.    Also removed the internal disk buffers that I created... Forgot that if
  40.    your using TBufStream, its already buffered.  Why waste the memory
  41.    buffering it twice?!?
  42.  
  43.    NOTE: This version is no longer compatable with those published before it.
  44.  
  45. }
  46.  
  47. {$F+,O+,S-,R-}
  48.  
  49. Interface
  50.  
  51. Uses Dos, Objects, Memory;
  52.  
  53. CONST stStoreError      = -120;
  54.       stStoreReadErr    = 197;
  55.       stStoreWriteErr   = 198;
  56.       stStoreUnknownErr = 199;
  57.       MemOverflow       = 1005;
  58.  
  59. TYPE  PBuffer  = ^BBuffer;
  60.       BBuffer  = ARRAY [0..65530] OF BYTE;
  61.  
  62.       PList    = ^LList;
  63.       LList    = RECORD
  64.                     OldItem : LONGINT;
  65.                     NewItem : LONGINT;
  66.                     Next    : PList;
  67.                  END;
  68.  
  69.       PStorage = ^TStorage;
  70.       TStorage = OBJECT(TBufStream)
  71.                     SFileName   : FNameStr;
  72.                     SCleanName  : FNameStr;
  73.                     SCleanIndex : PList;
  74.                     SMode       : WORD;
  75.                     SHoldBuf    : POINTER;
  76.                     SHoldBufLen : WORD;
  77.                     CONSTRUCTOR Init(AFileName : FNameStr; AMode, Size : WORD);
  78.                     DESTRUCTOR Done; VIRTUAL;
  79.  
  80.                     FUNCTION  WriteMsg(BufBytes : WORD; VAR Buf) : LONGINT;
  81.                     FUNCTION  ReadMsg(Index : LONGINT; VAR Buf : POINTER) : WORD;
  82.                     PROCEDURE DeleteMsg(Index : LONGINT);
  83.                     PROCEDURE CleanUpMsg;
  84.                     FUNCTION  NewIndex(Index : LONGINT) : LONGINT;
  85.                     PROCEDURE DeleteCleanUp;
  86.  
  87.                     PROCEDURE InitCompress; VIRTUAL;
  88.                     FUNCTION  Compress(NumBytes : WORD; VAR CompType : BYTE;
  89.                                        VAR Buf) : WORD; VIRTUAL;
  90.                     PROCEDURE DeCompress(NumBytes : WORD; CompType : BYTE; VAR Buf); VIRTUAL;
  91.                  END;
  92.  
  93. Implementation
  94.  
  95. CONST MarkerWord = $114D4410;    {Some sort of magic number!}
  96.  
  97. TYPE  Header     = RECORD
  98.                       Marker       : LONGINT;
  99.                       ExpandSize   : WORD;
  100.                       CompressSize : WORD;
  101.                       CompressType : BYTE
  102.                    END;
  103.  
  104. VAR   Head : Header;
  105.  
  106. {----------------------------------------------------------------------------}
  107.  
  108. CONSTRUCTOR TStorage.Init;
  109. BEGIN
  110.    TBufStream.Init(AFileName,AMode,Size);
  111.    IF Status <> stOk THEN
  112.       Status := stStoreError
  113.    ELSE
  114.       BEGIN
  115.          SFileName   := FEXPAND(AFileName);
  116.          SCleanName  := '';
  117.          SCleanIndex := NIL;
  118.          SMode       := AMode;
  119.          SHoldBuf    := NIL;
  120.          SHoldBufLen := 0
  121.       END
  122. END;
  123.  
  124. {----------------------------------------------------------------------------}
  125.  
  126. FUNCTION TStorage.WriteMsg;
  127. VAR   SIndex : LONGINT;
  128. BEGIN
  129.    SIndex := GetSize;
  130.    WriteMsg := SIndex;
  131.  
  132.    WITH Head DO BEGIN
  133.       Marker       := MarkerWord;
  134.       ExpandSize   := BufBytes;
  135.       CompressSize := 0;
  136.       CompressType := 0
  137.    END;
  138.  
  139.    TBufStream.Seek(SIndex);
  140.    TBufStream.Write(Head,SIZEOF(Head));
  141.    Head.CompressSize := Compress(BufBytes,Head.CompressType,Buf);
  142.    TBufStream.Seek(SIndex);
  143.    TBufStream.Write(Head,SIZEOF(Head));
  144.    TBufStream.Flush;
  145.  
  146.    IF Status <> stOk THEN
  147.       Status := stStoreError
  148. END;
  149.  
  150. {----------------------------------------------------------------------------}
  151.  
  152. FUNCTION TStorage.ReadMsg;
  153. VAR   DeleteCheck : BYTE;
  154. BEGIN
  155.    IF (SHoldBuf <> NIL) AND (SHoldBufLen > 0) THEN
  156.       FREEMEM(SHoldBuf,SHoldBufLen);
  157.    SHoldBuf    := NIL;
  158.    SHoldBufLen := 0;
  159.    ReadMsg     := 0;
  160.    TBufStream.Seek(Index);
  161.    TBufStream.Read(Head,SIZEOF(Head));
  162.  
  163.    IF Head.Marker <> MarkerWord THEN
  164.       BEGIN
  165.          Head.ExpandSize := TBufStream.GetSize - Index;
  166.          IF Head.ExpandSize > 65530 THEN
  167.             Head.ExpandSize := 65530;
  168.          Head.CompressSize := Head.ExpandSize;
  169.          Head.CompressType := 0;
  170.          TBufStream.Seek(Index)
  171.       END
  172.    ELSE
  173.       IF Head.CompressType = $FF THEN
  174.          EXIT;
  175.  
  176.    SHoldBuf := MemAlloc(Head.ExpandSize);
  177.    IF SHoldBuf <> NIL THEN
  178.       BEGIN
  179.          SHoldBufLen := Head.ExpandSize;
  180.          DeCompress(Head.CompressSize,Head.CompressType,SHoldBuf^);
  181.          ReadMsg := Head.ExpandSize
  182.       END
  183.    ELSE
  184.       Error(stStoreError,MemOverflow);
  185.  
  186.    Buf := SHoldBuf;
  187.    IF Status <> stOk THEN
  188.       Status := stStoreError
  189. END;
  190.  
  191. {----------------------------------------------------------------------------}
  192.  
  193. PROCEDURE TStorage.DeleteMsg;
  194. VAR   CompressType : BYTE;
  195. BEGIN
  196.    Seek(Index);
  197.    Read(Head,SIZEOF(Head));
  198.    IF Head.Marker = MarkerWord THEN
  199.       BEGIN
  200.          Seek(Index);
  201.          Head.CompressType := $FF;   {Mark Compression Type as Deleted!}
  202.          Write(Head,SIZEOF(Head))
  203.       END;
  204.    IF Status <> stOk THEN
  205.       Status := stStoreError
  206. END;
  207.  
  208. {----------------------------------------------------------------------------}
  209.  
  210. PROCEDURE TStorage.CleanUpMsg;
  211. VAR   Dir     : DirStr;
  212.       FName   : NameStr;
  213.       Ext     : ExtStr;
  214.       T       : TBufStream;
  215.       TmpPtr  : POINTER;
  216.       TFile   : FILE;
  217.       OldItem : LONGINT;
  218.       NewItem : LONGINT;
  219.       LinkPtr : PList;
  220. BEGIN
  221.    FSplit(SFileName,Dir,FName,Ext);
  222.    SCleanName := Dir + FName + '.$$$';
  223.    T.Init(SCleanName,stCreate,1024);
  224.    Seek(0);
  225.    OldItem := 0;
  226.    WHILE (OldItem < GetSize - 1) AND (Status = stOk) DO BEGIN
  227.       Read(Head,SIZEOF(Head));
  228.       IF Head.Marker <> MarkerWord THEN
  229.          Error(stStoreError,stStoreUnknownErr)
  230.       ELSE
  231.          BEGIN
  232.             TmpPtr := MemAlloc(Head.CompressSize);
  233.             IF TmpPtr = NIL THEN
  234.                Error(stStoreError,MemOverflow)
  235.             ELSE
  236.                BEGIN
  237.                   Read(TmpPtr^,Head.CompressSize);
  238.                   IF (Status = stOk) AND (Head.CompressType < $FF) THEN
  239.                      BEGIN
  240.                         NewItem := T.GetPos;
  241.                         T.Write(Head,SIZEOF(Head));
  242.                         T.Write(TmpPtr^,Head.CompressSize);
  243.                         GETMEM(LinkPtr,SIZEOF(LList));
  244.                         LinkPtr^.OldItem := OldItem;
  245.                         LinkPtr^.NewItem := NewItem;
  246.                         LinkPtr^.Next := SCleanIndex;
  247.                         SCleanIndex := LinkPtr
  248.                      END;
  249.                   FREEMEM(TmpPtr,Head.CompressSize);
  250.                   OldItem := GetPos
  251.                END
  252.          END
  253.    END;
  254.    T.Done;
  255.    IF Status <> stOk THEN
  256.       BEGIN
  257.          ASSIGN(TFile,SCleanName);
  258.          ERASE(TFile);
  259.          SCleanName := '';
  260.          Status := stStoreError
  261.       END
  262. END;
  263.  
  264. {----------------------------------------------------------------------------}
  265.  
  266. FUNCTION TStorage.NewIndex;
  267. VAR   PLink : PList;
  268. BEGIN
  269.    PLink := SCleanIndex;
  270.    NewIndex := -1;
  271.    WHILE (PLink <> NIL) AND (PLink^.OldItem <> Index) DO
  272.       PLink := PLink^.Next;
  273.    IF (PLink <> NIL) AND (PLink^.OldItem = Index) THEN
  274.       NewIndex := PLink^.NewItem
  275. END;
  276.  
  277. {----------------------------------------------------------------------------}
  278.  
  279. PROCEDURE TStorage.DeleteCleanUp;
  280. VAR   TFile : FILE;
  281.       PLink : PList;
  282. BEGIN
  283.    IF SCleanName <> '' THEN
  284.       BEGIN
  285.          {$I-} ASSIGN(TFile,SCleanName);
  286.          ERASE(TFile); {$I+}
  287.          ErrorInfo := IOResult;
  288.          IF ErrorInfo <> stOk THEN
  289.             Status := stStoreError;
  290.          SCleanName := '';
  291.          WHILE SCleanIndex <> NIL DO BEGIN
  292.             PLink := SCleanIndex;
  293.             SCleanIndex := PLink^.Next;
  294.             FREEMEM(PLink,SIZEOF(LList))
  295.          END
  296.       END
  297. END;
  298.  
  299. {----------------------------------------------------------------------------}
  300.  
  301. CONST BitMask : ARRAY[0..7] OF BYTE = (1,2,4,8,16,32,64,128);
  302.  
  303. VAR   Up      : ARRAY[0..512] OF BYTE;
  304.       Left    : ARRAY[0..255] OF WORD;
  305.       Right   : ARRAY[0..255] OF WORD;
  306.  
  307. PROCEDURE Splay(Code : WORD);  {Note 0..255 are characters, 256 is EOF}
  308. VAR   a : WORD;
  309.       b : WORD;
  310.       c : BYTE;
  311.       d : BYTE;
  312. BEGIN
  313.    a := Code + 256;
  314.    REPEAT
  315.       c := Up[a];
  316.       IF c <> 0 THEN
  317.          BEGIN
  318.             d := Up[c];
  319.             b := Left[d];
  320.             IF c = b THEN
  321.                BEGIN
  322.                   b := Right[d];
  323.                   Right[d] := a
  324.                END
  325.             ELSE
  326.                Left[d] := a;
  327.             IF a = Left[c] THEN
  328.                Left[c] := b
  329.             ELSE
  330.                Right[c] := b;
  331.             Up[a] := d;
  332.             Up[b] := c;
  333.             a := d
  334.          END
  335.       ELSE
  336.          a := c
  337.    UNTIL a = 0
  338. END;
  339.  
  340. {----------------------------------------------------------------------------}
  341.  
  342. FUNCTION TStorage.Compress;
  343. VAR   i          : WORD;
  344.       NumWritten : WORD;
  345.       BitPos     : BYTE;
  346.       OutByte    : BYTE;
  347.  
  348.    PROCEDURE WriteByte;
  349.    BEGIN
  350.       TBufStream.Write(OutByte,1);
  351.       INC(NumWritten);
  352.       BitPos := 0;
  353.       OutByte := 0
  354.    END;
  355.  
  356.    PROCEDURE Comp(Code : WORD);
  357.    VAR   a     : WORD;
  358.          u     : BYTE;
  359.          sp    : WORD;
  360.          Stack : ARRAY[0..255] OF BOOLEAN;
  361.    BEGIN
  362.       a := Code + 256;
  363.       sp := 0;
  364.       REPEAT
  365.          u := Up[a];
  366.          Stack[sp] := (Right[u] = a);
  367.          INC(sp);
  368.          a := u
  369.       UNTIL a = 0;
  370.       REPEAT
  371.          DEC(sp);
  372.          IF Stack[sp] THEN
  373.             OutByte := OutByte OR BitMask[BitPos];
  374.          IF BitPos = 7 THEN
  375.             WriteByte
  376.          ELSE
  377.             INC(BitPos)
  378.       UNTIL sp = 0;
  379.       Splay(Code)
  380.    END;
  381.  
  382. BEGIN
  383.    InitCompress;
  384.    BitPos := 0;
  385.    OutByte := 0;
  386.    CompType := 2;
  387.    Compress := 0;
  388.    NumWritten := 0;
  389.  
  390.    FOR i := 0 TO NumBytes - 1 DO
  391.       Comp(BBuffer(Buf)[i]);
  392.    Comp(256);                     {EOF Marker}
  393.  
  394.    IF BitPos <> 0 THEN
  395.       WriteByte;
  396.    Compress := NumWritten
  397. END;
  398.  
  399. {----------------------------------------------------------------------------}
  400.  
  401. PROCEDURE TStorage.DeCompress;
  402. VAR   NumWritten : WORD;
  403.       BufRead    : WORD;
  404.       InByte     : BYTE;
  405.       OutByte    : WORD;
  406.       BitPos     : BYTE;
  407.  
  408.    FUNCTION Expand : WORD;
  409.    VAR   a : WORD;
  410.    BEGIN
  411.       a := 0;
  412.       REPEAT
  413.          IF BitPos = 7 THEN
  414.             BEGIN
  415.                TBufStream.Read(InByte,1);
  416.                BitPos := 0
  417.             END
  418.          ELSE
  419.             INC(BitPos);
  420.          IF InByte AND BitMask[BitPos] = 0 THEN
  421.             a := Left[a]
  422.          ELSE
  423.             a := Right[a]
  424.       UNTIL a > 255;
  425.       DEC(a,256);
  426.       Splay(a);
  427.       Expand := a
  428.    END;
  429.  
  430. BEGIN
  431.    CASE CompType OF
  432.       0 : TBufStream.Read(Buf,NumBytes);
  433.       2 : BEGIN
  434.              InitCompress;
  435.              BitPos := 7;
  436.              BufRead := 0;
  437.              NumWritten := 0;
  438.  
  439.              OutByte := Expand;
  440.              WHILE OutByte <> 256 DO BEGIN
  441.                 BBuffer(Buf)[NumWritten] := OutByte;
  442.                 INC(NumWritten);
  443.                 OutByte := Expand
  444.              END
  445.           END
  446.    END
  447. END;
  448.  
  449. {----------------------------------------------------------------------------}
  450.  
  451. PROCEDURE TStorage.InitCompress;
  452. VAR   i : WORD;
  453.       j : BYTE;
  454.       k : WORD;
  455. BEGIN
  456.    FOR i := 1 TO 512 DO
  457.       Up[i] := (i - 1) SHR 1;
  458.    FOR j := 0 TO 255 DO BEGIN
  459.       k := (j + 1) SHL 1;
  460.       Left[j] := k - 1;
  461.       Right[j] := k
  462.    END
  463. END;
  464.  
  465. {----------------------------------------------------------------------------}
  466.  
  467. DESTRUCTOR TStorage.Done;
  468. VAR   TFile : FILE;
  469.       PLink : PList;
  470. BEGIN
  471.    IF (SHoldBuf <> NIL) AND (SHoldBufLen > 0) THEN
  472.       FREEMEM(SHoldBuf,SHoldBufLen);
  473.    TBufStream.Done;
  474.    IF SCleanName <> '' THEN
  475.       BEGIN
  476.          ASSIGN(TFile,SFileName);
  477.          ERASE(TFile);
  478.          ASSIGN(TFile,SCleanName);
  479.          RENAME(TFile,SFileName);
  480.          SCleanName := ''
  481.       END;
  482.    WHILE SCleanIndex <> NIL DO BEGIN
  483.       PLink := SCleanIndex;
  484.       SCleanIndex := PLink^.Next;
  485.       FREEMEM(PLink,SIZEOF(LList))
  486.    END
  487.  
  488. END;
  489.  
  490. {----------------------------------------------------------------------------}
  491.  
  492. END.
  493.  
  494.  
  495.  
  496.  
  497.  
  498.  
  499.  
  500.  
  501.  
  502.  
  503.  
  504. (*--------------------------------------------------------------------------*)
  505. (*--              OLDER METHOD OF COMPRESSION/DECOMPRESSION               --*
  506. {----------------------------------------------------------------------------}
  507.  
  508. PROCEDURE TStorage.Compress;
  509. VAR   p          : PBuffer;
  510.       ReadPosn   : WORD;
  511.       WritePosn  : WORD;
  512.       SpaceCount : WORD;
  513. BEGIN
  514.    p := PBuffer(@Buf);
  515.    ReadPosn := 0;
  516.    WritePosn := 0;
  517.    WHILE (p^[ReadPosn] <> 0) AND (ReadPosn < 65530) DO BEGIN
  518.       SpaceCount := 0;
  519.       WHILE (p^[ReadPosn + SpaceCount] = 32) DO
  520.          INC(SpaceCount);
  521.       IF SpaceCount > 1 THEN
  522.          BEGIN
  523.             INC(ReadPosn,SpaceCount);
  524.             WHILE SpaceCount > 0 DO
  525.                IF SpaceCount > 255 THEN
  526.                   BEGIN
  527.                      p^[WritePosn] := 255;
  528.                      p^[WritePosn + 1] := 255;
  529.                      INC(WritePosn,2);
  530.                      DEC(SpaceCount,255)
  531.                   END
  532.                ELSE
  533.                   BEGIN
  534.                      p^[WritePosn] := 255;
  535.                      p^[WritePosn + 1] := SpaceCount;
  536.                      INC(WritePosn,2);
  537.                      SpaceCount := 0
  538.                   END;
  539.             SpaceCount := 2
  540.          END;
  541.       IF SpaceCount = 1 THEN
  542.          IF (p^[ReadPosn + 1] >= 64) AND (p^[ReadPosn + 1] <= 127) THEN
  543.             BEGIN
  544.                p^[WritePosn] := p^[ReadPosn + 1] + 128;
  545.                INC(WritePosn);
  546.                INC(ReadPosn,2)
  547.             END
  548.          ELSE
  549.             SpaceCount := 0;
  550.       IF SpaceCount = 0 THEN
  551.          BEGIN
  552.             IF p^[ReadPosn + 1] = 101 THEN
  553.                BEGIN
  554.                   p^[WritePosn] := p^[ReadPosn] + 64;
  555.                   INC(ReadPosn,2)
  556.                END
  557.             ELSE
  558.                BEGIN
  559.                   p^[WritePosn] := p^[ReadPosn];
  560.                   INC(ReadPosn)
  561.                END;
  562.             INC(WritePosn)
  563.          END
  564.    END;
  565.    p^[WritePosn] := 0;
  566.    MOVE(p^[0],p^[1],WritePosn + 1);
  567.    p^[0] := 1
  568. END;
  569.  
  570. {----------------------------------------------------------------------------}
  571.  
  572. PROCEDURE TStorage.DeCompress;
  573. VAR   p         : PBuffer;
  574.       ReadPosn  : WORD;
  575.       Count     : WORD;
  576.       Total     : WORD;
  577. BEGIN
  578.    p := PBuffer(@Buf);
  579.    ReadPosn := 0;
  580.    Total := 0;
  581.    WHILE (p^[Total + 1] <> 0) DO
  582.       INC(Total);
  583.    IF p^[0] = 1 THEN
  584.       BEGIN
  585.          MOVE(p^[1],p^[0],Total);
  586.          p^[Total] := 0;
  587.          WHILE (p^[ReadPosn] <> 0) AND (ReadPosn < SholdBufLen) DO BEGIN
  588.             CASE p^[ReadPosn] OF
  589.                255      : BEGIN
  590.                              Count := p^[ReadPosn + 1];
  591.                              MOVE(p^[ReadPosn + 2],p^[ReadPosn + Count],SHoldBufLen - ReadPosn - 2);
  592.                              FILLCHAR(p^[ReadPosn],Count,32);
  593.                              INC(ReadPosn,Count)
  594.                           END;
  595.                192..254 : BEGIN
  596.                              MOVE(p^[ReadPosn],p^[ReadPosn + 1],SHoldBufLen - ReadPosn);
  597.                              p^[ReadPosn] := 32;
  598.                                                  DEC(p^[ReadPosn + 1],128);
  599.                              INC(ReadPosn,2)
  600.                           END;
  601.                160..191 : BEGIN
  602.                              MOVE(p^[ReadPosn],p^[ReadPosn + 1],SHoldBufLen - ReadPosn);
  603.                              p^[ReadPosn + 1] := 101;
  604.                              DEC(p^[ReadPosn],64);
  605.                              INC(ReadPosn,2)
  606.                           END;
  607.  
  608.                000..159 : INC(ReadPosn)
  609.             END
  610.          END
  611.       END
  612. END;
  613.  
  614.  *--------------------------------------------------------------------------*)
  615.